home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / RING.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  3.7 KB  |  120 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. (define make-ring)
  43. (define ring-size)
  44. (define ring-clear!)
  45. (define ring-empty?)
  46. (define ring-push!)
  47. (define ring-pop!)
  48. (define ring-stack-pop!)
  49. (define ring-ref)
  50. (define ring-set!)
  51. (let ()
  52.  
  53. (define (list-ref l i)
  54.   (cond ((null? l) (error "Index too large" 'LIST-REF))
  55.     ((zero? i) (car l))
  56.     (else (list-ref (cdr l) (-1+ i)))))
  57.  
  58. (define (list-set! l i o)
  59.   (define (loop l i)
  60.     (cond ((null? l) (error "Index too large" 'LIST-SET!))
  61.       ((zero? i) (set-car! l o))
  62.       (else (list-ref (cdr l) (-1+ i)))))
  63.   (loop l i))
  64.  
  65. (define (list-truncate! l i)
  66.   (cond ((null? l) 'DONE)
  67.     ((= i 1) (set-cdr! l '()))
  68.     (else (list-truncate! (cdr l) (-1+ i)))))
  69.  
  70. (set! make-ring
  71. (named-lambda (make-ring size)
  72.   (if (< size 1)
  73.       (error "Ring size too small" size)
  74.       (let ((vec (make-vector 3)))
  75.         (vector-set! vec 0 "Ring")
  76.         (vector-set! vec 1 size)))))
  77.  
  78. (set! ring-size
  79. (named-lambda (ring-size ring)
  80.   (length (vector-ref ring 2))))
  81.  
  82. (set! ring-clear!
  83. (named-lambda (ring-clear! ring)
  84.   (vector-set! ring 2 '())))
  85.  
  86. (set! ring-empty?
  87. (named-lambda (ring-empty? ring)
  88.   (null? (vector-ref ring 2))))
  89.  
  90. (set! ring-push!
  91. (named-lambda (ring-push! ring object)
  92.   (vector-set! ring 2 (cons object (vector-ref ring 2)))
  93.   (list-truncate! (vector-ref ring 2) (vector-ref ring 1))))
  94.  
  95. (set! ring-pop!
  96. (named-lambda (ring-pop! ring)
  97.   (let ((l (vector-ref ring 2)))
  98.     (if (null? l)
  99.     (error "Ring empty" ring)
  100.     (let ((object (car l)))
  101.       (vector-set! ring 2 (append! (cdr l) (list object)))
  102.       object)))))
  103.  
  104. (set! ring-stack-pop!
  105.   (named-lambda (ring-stack-pop! ring n)
  106.     (let ((l (vector-ref ring 2)))
  107.       (if (> n (length l))
  108.           (error "Ring does not have enteries" ring)
  109.           (vector-set! ring 2 (list-tail l n))))))
  110.  
  111. (set! ring-ref
  112. (named-lambda (ring-ref ring index)
  113.   (list-ref (vector-ref ring 2) index)))
  114.  
  115. (set! ring-set!
  116. (named-lambda (ring-set! ring index object)
  117.   (list-set! (vector-ref ring 2) index object)))
  118.  
  119. )
  120.